InfoMagic Internet Tools 1993 July/Internet Tools.iso/RockRidge/info-service/www/src/fminit2.0/html.ol

Text File | 1992-11-17 | 5.4 KB | 234 lines

;;; html.ol -- objective lisp support for the WWW HTML format
;;; $Id: html.ol,v 1.2 92/11/17 21:59:51 connolly Exp $
;;;

(require 'SGML)

(defClass HTML SGML
  (ignore anchor-content)
  )

(defMethod HTML :ascii (data)
  ;; @@ watch out for </ in CDATA
  (cond (ignore)
    ((member (first gi-stack) '(XMP LISTING))
     [self :format "~A" data]
     )
    (t
     (flet ((sgml-markup (c)
                 (member c '(#\& #\<)) )
        )
           (do* ((p (position-if #'sgml-markup data)
            (position-if #'sgml-markup data))
             )
            ((null p)
             [self :format "~A" data]
             )
            [self :format "~A&~A;" (subseq data 0 p)
              (case (elt data p)
                (#\& '|amp|)
                (#\< '|lt|)
                )]
            (setq data (subseq data (1+ p)))
            ) )
     ) )
  (setq anchor-content t)
  )

(defMethod HTML :end-record ()
  ;; nothing
  )

(defMethod HTML :started (gi)
  (or (member gi gi-stack)
      [self :start gi])
  )

(defMethod HTML :ended (gi)
  (do ()
      ((null (member gi gi-stack)))
      [self :end (first gi-stack)]
      (send-super :end-record)
      ) )

(defMethod HTML :restore (gi)
  (do ()
      ((eq gi (first gi-stack)))
      [self :end (first gi-stack)]
      (send-super :end-record)
      ) )

(defMethod HTML :reset-paragraph-format (tag fmt)
  (cond ((eq tag 'TITLE)
     [self :started tag]
     )
    ((null (eq tag (first gi-stack)))
     [self :started 'document]
     [self :restore 'document]
     [self :started tag])
    )
  (case tag
    ((DIR MENU OL UL)
     [self :empty 'LI])
    (DL
     [self :empty 'DT]
     )
  ) )

(defMethod HTML :reset-character-format (tag foo)
  [self :end-anchor]
  )
(defMethod HTML :change-paragraph-format (foo)
  )
(defMethod HTML :change-character-format (foo)
  [self :end-anchor]
  )
(defMethod HTML :save-character-format ()
  (setq ignore t)
  )
(defMethod HTML :restore-character-format ()
  (setq ignore nil)
  )

(defMethod HTML :end-paragraph ()
  [self :end-anchor]
  (case (first gi-stack)

    (document
     [self :empty 'P]
     (send-super :end-record))
    ((ul ol dir menu dl)
     ;;nothing
     )
    (t [self :end (first gi-stack)]
       (send-super :end-record))
  ))

(defMethod HTML :end-section ()
  [self :ended 'DOCUMENT]
  )

(defMethod HTML :tab ()
  [self :end-anchor]
  (case (first gi-stack)
    (DL
     [self :empty 'DD]
     )
    ) )

(defMethod HTML :newline ()
  (case (first gi-stack)
    ((XMP LISTING)
     (send-super :end-record)
     )
    ) )

(defMethod HTML :start-anchor (name href &aux attrs)
  (if name (push `(name ,name) attrs))
  (if href (push `(href ,href) attrs))
  [self :start 'a attrs]
  (setq anchor-content nil)
  )

(defMethod HTML :end-anchor ()
  (if anchor-content [self :ended 'a])
  )

(defMethod HTML :mif-chars (chars)
  ;; @@ watch out for </ in CDATA
  (or ignore
      (dolist (c chars)
          (let ((i (char-int c))
            (cdata (member (first gi-stack) '(XMP LISTING)))
            )
        [self :format "~A"
              (cond ((and (null cdata) (eq c #\&)) "&")
                ((and (null cdata) (eq c #\<)) "<")
                ((< i 32) "_") ;;@@
                ((< i 128) c)
                (t (aref *FrameCharacterSet* (- i 128)))
                ) ] )
          ) ) )

(setq *FrameCharacterSet*
  #(
|Adieresis| |Aring| |Ccedilla| |Eacute|
|Ntilde| |Odieresis| |Udieresis| |aacute| |agrave|
|acircumflex| |adieresis| |atilde| |aring| |ccedilla|
|eacute| |egrave| |ecircumflex| |edieresis| |iacute|
|igrave| |icircumflex| |idieresis| |ntilde| |oacute|
|ograve| |ocircumflex| |odieresis| |otilde| |uacute|
|ugrave| |ucircumflex| |udieresis| |dagger| nil |cent|
|sterling| |section| "*" |paragraph| |germandbls|
"(R)" "(C)" "(TM)" |acute| |dieresis|
nil |AE| |Oslash| nil nil nil nil |yen| nil nil nil
nil nil nil |ordfeminine| |ordmasculine| nil |ae| |oslash|
|questiondown| |exclamdown| |logicalnot| nil |florin|
nil nil |guillemotleft| |guillemotright| |ellipsis|
nil |Agrave| |Atilde| |Otilde| |OE| |oe| "-" "--"
"``" "''" "`" "'"
nil nil |ydieresis| |Ydieresis| |fraction| "$"
"<" ">" "fi" "fl" |daggerdbl|
"*" "," ",," |perthousand|
|Acircumflex| |Ecircumflex| |Aacute| |Edieresis| |Egrave|
|Iacute| |Icircumflex| |Idieresis| |Igrave| |Oacute|
|Ocircumflex| nil |Ograve| |Uacute| |Ucircumflex| |Ugrave|
|dotlessi| |circumflex| "~" |macron| |breve| |dotaccent|
|ring| |cedilla| |hungarumlaut| |ogonek| |caron|
    ) )

(defMethod HTML :marker (type text)
  (case type
    (8 (let* ((str (make-string-input-stream text))
          (command (read str))
          )
         (case command
           (newlink (peek-char t str)
                [self :start-anchor (read-line str) nil])
           (gotolink [self :start-anchor nil (read-href str)])
           (message (let ((client (read str))
                  )
                  (peek-char t str) ;; skip whitespace
                  (case client
                    (www [self :start-anchor nil
                           (read-line str)] )
                    ) ))
           )
         ))
    ) )

(defun read-href (str)
  ;; parse foo:bar -> file:foo#bar
  ;;       bar -> #bar
  ;;       foo:firstpage -> file:foo
  (peek-char t str)
  (do (file
       anchor ex
       href
       (char (read-char str) (read-char str))
       )
      ((null char) ;; reached end of string
       (if file
       (setq href (concatenate 'string "file:" file)) )
       (cond ((null anchor) )
         ((eq 'firstpage (intern (concatenate 'string anchor))) )
         (t (setq href (concatenate 'string href "#"
                    anchor) )) )
       href
       )

      ;; body of do loop...
      (case char
        (#\: (setq file anchor)
         (setq anchor nil)
         (setq ex nil) )
        (t (let ((cell (cons char nil))
             )
         (if ex (setf (cdr ex) cell)
           (setf anchor cell) )
         (setf ex cell) ))
        )
      ) )

(provide 'html)